{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, DataKinds, PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Utils.GUIUtils
-- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GNU-GPL
--
-- Maintainer  :  <maintainer at leksah.org>
-- Stability   :  provisional
-- Portability :  portable
--
-- |
--
-------------------------------------------------------------------------------
module IDE.Utils.GUIUtils (
    chooseFile
,   chooseDir
,   chooseSaveFile
,   openBrowser
,   showDialog
,   showYesNoDialog
,   showConfirmDialog
,   showErrorDialog
,   showDialogOptions
,   showDialogAndGetResponse
,   showInputDialog

,   getFullScreenState
,   setFullScreenState
,   getDarkState
,   setDarkState

,   getBackgroundBuildToggled
,   setBackgroundBuildToggled
,   getMakeDocs
,   setMakeDocs
,   getRunUnitTests
,   setRunUnitTests
,   getRunBenchmarks
,   setRunBenchmarks
,   getMakeModeToggled
,   setMakeModeToggled
,   getNativeToggled
,   setNativeToggled
,   getJavaScriptToggled
,   setJavaScriptToggled
,   getDebugToggled
,   setDebugToggled

,   getRecentFiles
,   getRecentWorkspaces
,   getVCS

,   stockIdFromType
,   mapControlCommand
,   treeViewToggleRow
,   treeViewContextMenu
,   treeViewContextMenu'

,   __
,   printf

,   fontDescription
) where

import Prelude ()
import Prelude.Compat
import IDE.Utils.Tool (runProcess)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad (void, when, unless)
import IDE.Core.State
       (IDEAction, IDEM, DescrType(..), IDERef, readIDE, prefs,
        browser, sysMessage, MessageLevel(..), throwIDE, catchIDE,
        reifyIDE, reflectIDE, __)
import IDE.Gtk.State (PaneMonad, getUIAction, getUiManager, Connection(..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Exception as E
import Data.Text (Text)
import qualified Data.Text as T (unpack, pack)
import Data.List (intercalate)
import Data.Foldable (forM_)
import qualified Text.Printf as S (printf)
import Text.Printf (PrintfType)
import GI.Gtk.Objects.Window
       (setWindowWindowPosition, windowSetTransientFor, setWindowTitle,
        Window(..))
import GI.Gtk.Enums
       (WindowPosition(..), MessageType(..), ButtonsType(..), MessageType,
        ResponseType(..), FileChooserAction(..))
import Data.GI.Base.GObject (new')
import Data.GI.Base.GValue (GValueConstruct)
import Data.GI.Base.ManagedPtr (unsafeCastTo)
import GI.Gtk.Objects.FileChooserDialog (FileChooserDialog(..))
import GI.Gtk.Interfaces.FileChooser
       (fileChooserAddFilter, fileChooserGetFilename,
        fileChooserSetCurrentFolder, fileChooserSetAction)
import GI.Gtk.Objects.Dialog
       (Dialog(..), constructDialogUseHeaderBar, dialogGetContentArea)
import GI.Gtk.Objects.FileFilter
       (fileFilterAddPattern, fileFilterSetName, fileFilterNew)
import GI.Gtk.Objects.MessageDialog
       (constructMessageDialogText, constructMessageDialogButtons, constructMessageDialogMessageType,
        setMessageDialogMessageType, setMessageDialogText, MessageDialog(..))
import GI.Gtk.Objects.Box (Box(..))
import GI.Gtk.Objects.Label (labelNew)
import GI.Gtk.Objects.Entry (getEntryText, setEntryText, entryNew, onEntryActivate)
import Graphics.UI.Editor.Parameters
       (dialogSetDefaultResponse', dialogRun', dialogAddButton',
        boxPackStart', Packing(..))
import GI.Gtk.Objects.ToggleAction
       (toggleActionSetActive, toggleActionGetActive, ToggleAction(..))
import GI.Gtk.Objects.MenuItem
       (toMenuItem, onMenuItemActivate, menuItemNewWithLabel,
        MenuItem(..))
import GI.Gtk.Objects.UIManager (uIManagerGetWidget)
import GI.Gtk.Objects.TreeView
       (IsTreeView, TreeView(..), treeViewGetPathAtPos,
        treeViewGetSelection, treeViewExpandRow, treeViewCollapseRow,
        treeViewRowExpanded)
import GI.Gdk.Flags (ModifierType(..))
import GI.Gtk.Structs.TreePath
       (TreePath(..))
import GI.Gtk.Objects.Widget
       (widgetShowAll, widgetHide, widgetDestroy, widgetShow, widgetActivate)
import GI.Gtk.Objects.TreeSelection
       (treeSelectionSelectPath, treeSelectionUnselectAll, treeSelectionCountSelectedRows)
import Data.GI.Gtk.ModelView.ForestStore
       (forestStoreGetValue, ForestStore(..))
import GI.Gtk.Objects.Menu
       (Menu(..), menuAttachToWidget, menuNew)
import GI.Gtk.Objects.SeparatorMenuItem (separatorMenuItemNew)
import GI.Gtk.Objects.MenuShell (menuShellAppend)
import GI.Pango.Structs.FontDescription
       (fontDescriptionSetFamily, fontDescriptionNew, FontDescription(..))
import GI.Pango (fontDescriptionFromString)
import Data.GI.Base.BasicTypes (UnexpectedNullPointerReturn(..))
import Data.GI.Gtk.ModelView.Types
       (treeSelectionGetSelectedRows')
import GHC.Stack (HasCallStack)
import GI.Gdk
       (getEventButtonY, getEventButtonX, getEventButton, Event)
import GI.Gdk.Constants (pattern BUTTON_SECONDARY)
import GI.Gtk
       (menuPopupAtPointer, gestureGetLastEvent, onGestureBegin,
        gestureSingleSetButton, gestureMultiPressNew)

printf :: PrintfType r => Text -> r
printf = S.printf . T.unpack

chooseDir :: Window -> Text -> Maybe FilePath -> IO (Maybe FilePath)
chooseDir window prompt mbFolder = do
    dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1]
    setWindowTitle dialog prompt
    windowSetTransientFor dialog $ Just window
    fileChooserSetAction dialog FileChooserActionSelectFolder
    _ <- dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel
    _ <- dialogAddButton' dialog "gtk-open" ResponseTypeAccept
    mapM_ (fileChooserSetCurrentFolder dialog) mbFolder
    widgetShow dialog
    response <- dialogRun' dialog
    case response of
        ResponseTypeAccept -> do
            fn <- fileChooserGetFilename dialog
            widgetDestroy dialog
            return fn
        ResponseTypeCancel -> do
            widgetDestroy dialog
            return Nothing
        ResponseTypeDeleteEvent -> do
            widgetDestroy dialog
            return Nothing
        _                   -> return Nothing

-- | Launch a "choose file" dialog
chooseFile :: Window
           -> Text                   -- ^ Window title
           -> Maybe FilePath         -- ^ Start location
           -> [(String, [String])]   -- ^ File filters, e.g. [("Music Files", ["*.mp3", "*.wav"])]
           -> IO (Maybe FilePath)
chooseFile window prompt mbFolder filters = do
    dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1]
    setWindowTitle dialog prompt
    windowSetTransientFor dialog $ Just window
    fileChooserSetAction dialog FileChooserActionOpen
    _ <- dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel
    _ <- dialogAddButton' dialog "gtk-open" ResponseTypeAccept
    mapM_ (fileChooserSetCurrentFolder dialog) mbFolder
    forM_ filters (addFilter dialog)
    widgetShow dialog
    response <- dialogRun' dialog
    case response of
        ResponseTypeAccept -> do
            fn <- fileChooserGetFilename dialog
            widgetDestroy dialog
            return fn
        ResponseTypeCancel -> do
            widgetDestroy dialog
            return Nothing
        ResponseTypeDeleteEvent -> do
            widgetDestroy dialog
            return Nothing
        _                   -> return Nothing

    where
        addFilter dialog (description, exts) = do
            ff <- fileFilterNew
            fileFilterSetName ff . Just $ T.pack description
            forM_ exts (fileFilterAddPattern ff . T.pack)
            fileChooserAddFilter dialog ff

chooseSaveFile :: Window -> Text -> Maybe FilePath -> IO (Maybe FilePath)
chooseSaveFile window prompt mbFolder = do
    dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1]
    setWindowTitle dialog prompt
    windowSetTransientFor dialog $ Just window
    fileChooserSetAction dialog FileChooserActionSave
    _ <- dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel
    _ <- dialogAddButton' dialog "gtk-open" ResponseTypeAccept
    mapM_ (fileChooserSetCurrentFolder dialog) mbFolder
    widgetShow dialog
    res <- dialogRun' dialog
    case res of
        ResponseTypeAccept  ->  do
            fileName <- fileChooserGetFilename dialog
            widgetDestroy dialog
            return fileName
        _               ->  do
            widgetDestroy dialog
            return Nothing



openBrowser :: Text -> IDEAction
openBrowser url = do
    prefs' <- readIDE prefs
    liftIO (E.catch (
                void $ runProcess (T.unpack $ browser prefs') [T.unpack url] Nothing Nothing Nothing Nothing Nothing)
            (\ (_ :: SomeException) -> sysMessage Normal ("Can't find browser executable " <> browser prefs')))
    return ()

-- | Show a text dialog with an Ok button and a specific messagetype
showDialog :: MonadIO m => Maybe Window -> Text -> MessageType -> m ()
showDialog parent msg msgType =
    void $ showDialogAndGetResult parent msg msgType ResponseTypeOk [
            constructDialogUseHeaderBar 0,
            constructMessageDialogMessageType msgType,
            constructMessageDialogButtons ButtonsTypeOk,
            constructMessageDialogText msg
        ] [] []

-- | Show a Yes/No dialog
showYesNoDialog :: MonadIO m
                => Maybe Window -- ^ Parent of transient
                -> Bool         -- ^ Should Yes be selected by default?
                -> Text         -- ^ Message
                -> m Bool       -- ^ Was "Yes" chosen as user response?
showYesNoDialog parent defaultYes message =
    isYes <$> showDialogAndGetResponse parent message MessageTypeQuestion defaultResponse
            [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeYesNo ]
            []
  where
    defaultResponse = if defaultYes then ResponseTypeYes else ResponseTypeNo
    isYes = (== ResponseTypeYes)


-- | Show a confirmation dialog with a cancel button and a custom action
-- button
showConfirmDialog :: MonadIO m
                   => Maybe Window  -- ^ Parent of transient
                   -> Bool          -- ^ Should the custom action be selected by default?
                   -> Text          -- ^ Label for custom action button
                   -> Text          -- ^ Message
                   -> m Bool        -- ^ Was the custom action chosen as user response?
showConfirmDialog parent defaultConfirm action message =
    isConfirm <$> showDialogAndGetResponse parent message MessageTypeQuestion defaultResponse
            [ constructDialogUseHeaderBar 0 , constructMessageDialogButtons ButtonsTypeCancel ]
            [ (action, AnotherResponseType 1) ]
  where
    defaultResponse = if defaultConfirm then AnotherResponseType 1 else ResponseTypeCancel
    isConfirm = (== AnotherResponseType 1)

-- | Show an error dialog with an Ok button
showErrorDialog :: MonadIO m => Maybe Window -> Text -> m ()
showErrorDialog parent msg = showDialog parent msg MessageTypeError


-- | Show a dialog with custom buttons and callbacks
showDialogOptions :: MonadIO m
                  => Maybe Window     -- ^ Parent window to use with `windowSetTransientFor`
                  -> Text             -- ^ the message
                  -> MessageType      -- ^ type of dialog
                  -> [(Text, m ())]   -- ^ button text and corresponding actions
                  -> Maybe Int        -- ^ index of button that has default focus (0-based)
                  -> m ()
showDialogOptions parent msg msgType buttons mbIndex =
    void $ showDialogAndGetResult parent msg msgType (AnotherResponseType $ fromMaybe 0 mbIndex) [
                constructDialogUseHeaderBar 0,
                constructMessageDialogMessageType msgType,
                constructMessageDialogButtons ButtonsTypeNone,
                constructMessageDialogText msg
            ]
            (zip (map fst buttons) responseTypes)
            (zip responseTypes (map (const . snd) buttons))
  where
    responseTypes = (map AnotherResponseType [0..])

-- | Show a dialog with custom buttons, and get back the user response
showDialogAndGetResponse
        :: MonadIO m
        => Maybe Window   -- ^ Parent window to use with `windowSetTransientFor`
        -> Text           -- ^ The message
        -> MessageType    -- ^ The message dialog type
        -> ResponseType   -- ^ The response which is selected by default
        -> [IO (GValueConstruct MessageDialog)]   -- ^ Options to `new'` the window with
        -> [(Text, ResponseType)]     -- ^ List of buttons and their associated ResponseTypes
        -> m ResponseType -- ^ The response type selected by the user
showDialogAndGetResponse parent msg msgType defaultResponse newOptions buttons = do
    either id id <$>
        showDialogAndGetResult parent msg msgType
            defaultResponse newOptions buttons (actions buttons)
  where
    actions = map $ \(_, response) -> (response, const $ return response)

-- | Show a dialog with custom buttons, and perform an action based on the
-- user's response.
--
-- Note that, although the MessageDialog is passed to the actions, it will
-- not survive past the end of the call to `showDialogAndGetResult`, so
-- you should not try to store it somewhere for later use
showDialogAndGetResult
        :: MonadIO m
        => Maybe Window             -- ^ Parent window to use with `windowSetTransientFor`
        -> Text                     -- ^ The message
        -> MessageType              -- ^ The message dialog type
        -> ResponseType             -- ^ The response which is selected by default
        -> [IO (GValueConstruct MessageDialog)]   -- ^ Options to `new'` the window with
        -> [(Text, ResponseType)]   -- ^ List of buttons and their associated responseTypes
        -> [(ResponseType, MessageDialog -> m a)] -- ^ List of response types and their associated actions
        -> m (Either ResponseType a) -- ^ `Right` the result of the action selected by the user,
                                     -- or `Left ResponseType` if the user's response did not match the provided ones
showDialogAndGetResult parent msg msgType defaultResponse newOptions buttons responseActions = do
    dialog <- liftIO $ new' MessageDialog newOptions
    setMessageDialogMessageType dialog msgType
    setMessageDialogText dialog msg
    windowSetTransientFor dialog parent
    mapM_ (addActionButton dialog) buttons
    dialogSetDefaultResponse' dialog defaultResponse
    setWindowWindowPosition dialog WindowPositionCenterOnParent

    response <- dialogRun' dialog
    -- Keep the dialog alive until the caller's action has finished messing with it
    widgetHide dialog

    let action = lookup response responseActions
    result <- case action of
                 Nothing -> return $ Left response
                 Just f -> Right <$> f dialog

    widgetDestroy dialog
    return result
  where
    addActionButton :: MonadIO m => MessageDialog -> (Text, ResponseType) -> m ()
    addActionButton dialog (text, responseType) =
            dialogAddButton' dialog text responseType >> return ()

-- | Show a simple dialog that asks the user for some text
showInputDialog :: Maybe Window -- ^ Parent window to use with `windowSetTransientFor`
                -> Text -- ^ The message text
                -> Text -- ^ The default value
                -> IO (Maybe Text)
showInputDialog parent msg def = do
    dialog <- new' Dialog [constructDialogUseHeaderBar 1] -- Nothing [] MessageQuestion ButtonsOkCancel msg
    windowSetTransientFor dialog parent
    vbox   <- dialogGetContentArea dialog >>= unsafeCastTo Box
    label  <- labelNew (Just msg)
    entry  <- entryNew
    setEntryText entry def
    boxPackStart' vbox label PackNatural 0
    boxPackStart' vbox entry PackNatural 0
    widgetShowAll vbox

    -- Can't use messageDialog because of https://github.com/gtk2hs/gtk2hs/issues/114
    _ <- dialogAddButton' dialog "Cancel" ResponseTypeCancel
    okBtn <- dialogAddButton' dialog "Ok" ResponseTypeOk
    _ <- onEntryActivate entry $ void $ widgetActivate okBtn
    dialogSetDefaultResponse' dialog ResponseTypeOk

    res <- dialogRun' dialog
    widgetHide dialog

    case res of
        ResponseTypeOk -> do
            text <- getEntryText entry
            widgetDestroy dialog
            return (Just text)
        _ -> widgetDestroy dialog >> return Nothing




-- get widget elements (menu & toolbar)


getFullScreenState :: PaneMonad alpha => alpha Bool
getFullScreenState = do
    ui <- getUIAction "ui/menubar/_View/_Full Screen" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setFullScreenState :: PaneMonad alpha => Bool -> alpha ()
setFullScreenState b = do
    ui <- getUIAction "ui/menubar/_View/_Full Screen" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getDarkState :: PaneMonad alpha => alpha Bool
getDarkState = do
    ui <- getUIAction "ui/menubar/_View/_Use Dark Interface" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setDarkState :: PaneMonad alpha => Bool -> alpha ()
setDarkState b = do
    ui <- getUIAction "ui/menubar/_View/_Use Dark Interface" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getMenuItem :: HasCallStack => Text -> IDEM MenuItem
getMenuItem path = (do
    uiManager' <- getUiManager
    mMenuItem <- uIManagerGetWidget uiManager' path
    case mMenuItem of
      Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " <> path)
      Just item -> liftIO $ unsafeCastTo MenuItem item)
        `catchIDE` \(_::UnexpectedNullPointerReturn) ->
            throwIDE ("State.hs>>getMenuItem: Can't find ui path " <> path)

getBackgroundBuildToggled :: PaneMonad alpha => alpha Bool
getBackgroundBuildToggled = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setBackgroundBuildToggled :: PaneMonad alpha => Bool -> alpha ()
setBackgroundBuildToggled b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getMakeDocs :: PaneMonad alpha => alpha Bool
getMakeDocs = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/MakeDocs" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setMakeDocs :: PaneMonad alpha => Bool -> alpha ()
setMakeDocs b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/MakeDocs" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getRunUnitTests :: PaneMonad alpha => alpha Bool
getRunUnitTests = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setRunUnitTests :: PaneMonad alpha => Bool -> alpha ()
setRunUnitTests b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getRunBenchmarks :: PaneMonad alpha => alpha Bool
getRunBenchmarks = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/RunBenchmarks" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setRunBenchmarks :: PaneMonad alpha => Bool -> alpha ()
setRunBenchmarks b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/RunBenchmarks" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getMakeModeToggled :: PaneMonad alpha => alpha Bool
getMakeModeToggled = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setMakeModeToggled :: PaneMonad alpha => Bool -> alpha ()
setMakeModeToggled b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getNativeToggled :: PaneMonad alpha => alpha Bool
getNativeToggled = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/Native" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setNativeToggled :: PaneMonad alpha => Bool -> alpha ()
setNativeToggled b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/Native" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getJavaScriptToggled :: PaneMonad alpha => alpha Bool
getJavaScriptToggled = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/JavaScript" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setJavaScriptToggled :: PaneMonad alpha => Bool -> alpha ()
setJavaScriptToggled b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/JavaScript" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getDebugToggled :: PaneMonad alpha => alpha Bool
getDebugToggled = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" (unsafeCastTo ToggleAction)
    toggleActionGetActive ui

setDebugToggled :: PaneMonad alpha => Bool -> alpha ()
setDebugToggled b = do
    ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" (unsafeCastTo ToggleAction)
    toggleActionSetActive ui b

getRecentFiles , getRecentWorkspaces, getVCS :: HasCallStack => IDEM MenuItem
getRecentFiles    = getMenuItem "ui/menubar/_File/Recent Files"


getRecentWorkspaces = getMenuItem "ui/menubar/_File/Recent Workspaces"
getVCS = getMenuItem "ui/menubar/Version _Control" --this could fail, try returning Menu if it does
-- (toolbar)

stockIdFromType :: DescrType -> Text
stockIdFromType Variable        =   "ide_function"
stockIdFromType Newtype         =   "ide_newtype"
stockIdFromType Type            =   "ide_type"
stockIdFromType Data            =   "ide_data"
stockIdFromType Class           =   "ide_class"
stockIdFromType Instance        =   "ide_instance"
stockIdFromType Constructor     =   "ide_konstructor"
stockIdFromType Field           =   "ide_slot"
stockIdFromType Method          =   "ide_method"
stockIdFromType PatternSynonym  =   "ide_konstructor"
stockIdFromType _               =   "ide_other"


-- | Toggles a row in a `TreeView`
treeViewToggleRow :: (MonadIO m, IsTreeView treeView) => treeView -> TreePath -> m Bool
treeViewToggleRow treeView path = do
    expanded <- treeViewRowExpanded treeView path
    if expanded
        then treeViewCollapseRow treeView path
        else treeViewExpandRow   treeView path False

-- maps control key for Macos
mapControlCommand :: ModifierType -> ModifierType
#if defined(darwin_HOST_OS)
mapControlCommand ModifierTypeMod1Mask = ModifierTypeControlMask
#endif
mapControlCommand a = a

-- | Sets the context menu for a treeView widget
treeViewContextMenu' :: TreeView                 -- ^ The view
                     -> ForestStore a              -- ^ The model
                     -> (a -> TreePath -> ForestStore a -> IDEM [[(Text, IDEAction)]]) -- ^ Produces the menu items for the selected values when right clicking
                                                                                     -- The lists are seperated by a seperator
                     -> IDEM [Connection]
treeViewContextMenu' view store itemsFor = reifyIDE $ \ideRef -> do
    g <- gestureMultiPressNew view
    gestureSingleSetButton g (fromIntegral BUTTON_SECONDARY)
    cid2 <- onGestureBegin g $ \s ->
      gestureGetLastEvent g s >>= mapM_ (\event -> do
        eventButton <- getEventButton event
        x         <- getEventButtonX eventButton
        y         <- getEventButtonY eventButton
        sel <- treeViewGetSelection view
        selCount <- treeSelectionCountSelectedRows sel
        when (selCount <= 1) $ do
            pathInfo <- treeViewGetPathAtPos view (floor x) (floor y)
            case pathInfo of
                (True, Just path, _, _, _) -> do
                    treeSelectionUnselectAll sel
                    treeSelectionSelectPath sel path
                _ -> return ()
        showMenu event ideRef)
    return $ map (ConnectC view) [cid2]
  where
    showMenu :: Event -> IDERef -> IO ()
    showMenu event ideRef = do

        selPaths     <- treeViewGetSelection view >>= treeSelectionGetSelectedRows'
        selValues    <- mapM (forestStoreGetValue store) selPaths
        theMenu      <- menuNew
        menuAttachToWidget theMenu view Nothing
        forM_ (listToMaybe $ zip selValues selPaths) $ \(val, path) -> do
            itemsPerSection     <- flip reflectIDE ideRef $ itemsFor val path store
            menuItemsPerSection <- mapM (mapM (menuItemNewWithLabel . fst)) itemsPerSection


            forM_ (zip itemsPerSection menuItemsPerSection) $ \(section, itemsSection) ->
                forM_ (zip section itemsSection) $ \((_, onActivated), m) ->
                    onMenuItemActivate m $ reflectIDE onActivated ideRef

            unless (null itemsPerSection) $ do
                itemsAndSeparators <- sequence $
                    intercalate [separatorMenuItemNew >>= toMenuItem]
                                (map (map return) menuItemsPerSection)
                mapM_ (menuShellAppend theMenu) itemsAndSeparators
                widgetShowAll theMenu
                menuPopupAtPointer theMenu (Just event)

treeViewContextMenu :: MonadIO m
                    => TreeView
                    -> (Menu -> IO ())
                    -> m [Connection]
treeViewContextMenu treeView populateMenu = do
    theMenu <- menuNew
    menuAttachToWidget theMenu treeView Nothing
    liftIO $ populateMenu theMenu
    g <- gestureMultiPressNew treeView
    gestureSingleSetButton g (fromIntegral BUTTON_SECONDARY)
    cid2 <- onGestureBegin g $ \s ->
      gestureGetLastEvent g s >>= mapM_ (\event -> do
        eventButton <- getEventButton event
        x         <- getEventButtonX eventButton
        y         <- getEventButtonY eventButton
        sel <- treeViewGetSelection treeView
        selCount <- treeSelectionCountSelectedRows sel
        when (selCount <= 1) $ do
            pathInfo <- treeViewGetPathAtPos treeView (floor x) (floor y)
            case pathInfo of
                (True, Just path, _, _, _) -> do
                    treeSelectionUnselectAll sel
                    treeSelectionSelectPath sel path
                _ -> return ()
        showMenu event theMenu)
    return $ map (ConnectC treeView) [cid2]
  where
    showMenu event theMenu = do
        widgetShowAll theMenu
        menuPopupAtPointer theMenu (Just event)

fontDescription :: Maybe Text -> IDEM FontDescription
fontDescription mbFontString =
    case mbFontString of
        Just str ->
            fontDescriptionFromString str
        Nothing -> do
            f <- fontDescriptionNew
            fontDescriptionSetFamily f "Monospace"
            return f

